home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FM Towns: Free Software Collection 4
/
FM Towns Free Software Collection 4 - Disc 1.iso
/
oh_towns
/
mkradio
/
mrd.bas
< prev
next >
Wrap
BASIC Source File
|
1991-10-18
|
14KB
|
388 lines
10 '
20 ' Make Radio Drama
30 ' by J
40 '
50 '
60 *INIT
70 CLEAR ,,512,800000
80 SCREEN@ 0: WIDTH 80,25:COLOR 0,0,0,4
90 DIM PCMDATA%(288016),PCMBUF%(96016),VDBUF%(130)
100 DIM CMDNAMES$(8),FLNAMES$(14),FLLNG&(14),STAT%(600)
110 DEFLNG A-N:I=1:J=1:K=1:A1=1:A2=1:ADR1=1:ADR2=1:ARG0=1:ARG1=1:ARG2=1
120 CL=1:CHENGE_F=1:RETRY_F=1:MARK=1:DIVP=1:CMD_SW=1:CMD_IND=1:NUM=1
130 LOC0=1:LOC1=1:LOC2=1:LOC3=1
140 CMD_NUM=6
150 FOR I=0 TO 7:PCMDATA%(I)=65+I:NEXT I
160 PCMDATA%(4)=RAND*10000:PCMDATA%(6)=-18944:PCMDATA%(7)=8
170 PCMDATA%(8)=-18832:PCMDATA%(10)=0:PCMDATA%(12)=1568:PCMDATA%(14)=60
180 YESNO$="[yes=左クリック no=右クリック]"
190 WA$= "時間がかかりますが,辛抱強くお待ち下さい."
200 ON ERROR GOTO *ERROR
210 '
220 RESTORE *COLOR
230 FOR I=0 TO 15:READ LOC0,LOC1,LOC2:PALETTE I,[LOC0,LOC1,LOC2]:NEXT I
240 '
250 RESTORE *CMDNAMES
260 FOR I=1 TO CMD_NUM:READ CMDNAMES$(I):NEXT I
270 '
280 MOUSE 0:MOUSE 1,20,20,1
290 '
300 ':::::::::::::::::::::::::::::::::::::::: Main Routine :::::::
310 GOSUB *MAIN_MENU
320 *MAIN_LOOP
330 GOSUB *GET_MOUSE :IF ARG0=1 THEN *MAIN_LOOP
340 GOSUB *GET_CMD_POSI
350 IF CMD_IND=0 OR CMD_IND >CMD_NUM THEN *MN_SKIP
360 CMD_SW=2: GOSUB *WRITE_CMD
370 ON CMD_IND GOSUB *PLAY,*REC,*MAKE,*QUIT,*SV1,*HCOPY
380 CMD_SW=1: GOSUB *WRITE_CMD : GOTO *MAIN_LOOP
390 *MN_SKIP
400 GOSUB *GET_ED_POSI
410 IF ARG0=0 THEN *MN_SKIP2
420 IF ARG0 <15 THEN GOSUB *FILE_LOAD ELSE GOSUB *PATTERN_EDIT
430 GOTO *MAIN_LOOP
440 *MN_SKIP2
450 IF ARG1 <20 OR ARG1 >619 THEN *MAIN_LOOP
460 IF ARG2 < 230 OR ARG2 > 240 THEN *MAIN_LOOP
470 GOSUB *ERASE_PATTERN
480 GOTO *MAIN_LOOP
490 '
500 *QUIT
510 TMSG$="終了します."+YESNO$
520 GOSUB *WRITE_TMSG
530 GOSUB *GET_MOUSE
540 IF ARG0=1 THEN GOSUB *ERASE_TMSG:RETURN
550 TMSG$=" Good Luck and Good Bye " : GOSUB *WRITE_TMSG
560 MOUSE 5
570 END
580 ':::::::::::::::::::::::::::::::::::: End Main ::::::::::::::::::::
590 '
600 *MAIN_MENU
610 CLS
620 LINE(2,2)-(637,477),PSET,%15,B
630 LINE(6,6)-(444,91),PSET,%15,BF,%1
640 SYMBOL (0,32) ," Make Radio Drama ",3,3,%5,,,6
650 LINE(450,20)-(633,105),PSET,%15,B
660 LINE(6,112)-(633,245),PSET,%15,BF,%4
670 LINE(6,262)-(633,398),PSET,%2,BF,%0
680 LINE(19,141)-(620,207),PSET,%15,BF,%0
690 LINE(19,230)-(620,240),PSET,%15,BF,%0
700 SYMBOL (7,117)," Sound Pattern ",1,1,%1,,,4
710 GOSUB *ERASE_TMSG
720 FOR ARG0=1 TO 14
730 GOSUB *WRITE_ED_MENU
740 NEXT ARG0
750 FOR I=0 TO 30
760 IF I MOD 10 = 0 THEN SYMBOL (8+20*I,210),STR$(I),1,1,%15,,,0
770 LINE(19+20*I,230)-(19+20*I,225),PSET,%15
780 NEXT I:
790 CMD_SW=1:GOSUB *WRITE_ALL_CMD
800 FOR ARG0= 20 TO 619
810 STAT%(ARG0-19)=0
820 LINE(ARG0,231)-(ARG0,239),PSET,%1
830 NEXT ARG0
840 RETURN
850 '
860 ':::::::::::::::::::::::::::::::::: Service Routine :::::::::::::
870 *PLAY
880 PCMPLAY PCMDATA%
890 RETURN
900 '
910 *REC
920 TMSG$="10秒間録音します. 準備ができたら左クリックしてください."
930 GOSUB *WRITE_TMSG
940 GOSUB *GET_MOUSE :IF ARG0=1 THEN *REC_END
950 TMSG$="Recording" :GOSUB *WRITE_TMSG
960 PCMREC PCMBUF%,19200
970 '
980 TMSG$="終了しました. 試聴"+YESNO$
990 GOSUB *WRITE_TMSG :GOSUB *GET_MOUSE
1000 IF ARG0=1 THEN *REC_SKIP
1010 PCMPLAY PCMBUF%
1020 TMSG$="もう一度録音し直しますか? "+YESNO$
1030 GOSUB *WRITE_TMSG
1040 GOSUB *GET_MOUSE :IF ARG0=0 THEN *REC
1050 *REC_SKIP
1060 EXT$="snd":GOSUB *FILE_MSG
1070 IF MID$(A$,2,1)=":" THEN A$=LEFT$(A$,2)+"(1)"+RIGHT$(A$,LEN(A$)-2) ELSE A$="(1)"+A$
1080 TMSG$="save中です."+WA$: GOSUB *WRITE_TMSG
1090 ADR1=VARPTR(PCMBUF%(0))
1100 OPEN "R",#1,A$:FIELD #1,1 AS B$
1110 *REC_SKIP1
1120 FOR J=0 TO 9
1130 LOCATE 60,23:PRINT "今";J;"秒目です"
1140 FOR I=1 TO 19200
1150 LSET B$=CHR$(PEEK(ADR1)):PUT #1:ADR1=ADR1+1
1160 NEXT I
1170 NEXT J
1180 *REC_END: CLOSE #1 :GOSUB *ERASE_TMSG :CLS 4
1190 RETURN
1200 '
1210 *SV1
1220 TMSG$="何秒目からsaveしますか" :GOSUB *WRITE_TMSG
1230 LOCATE 30,23 :INPUT LOC0 :CLS 4 :IF LOC0<1 THEN LOC1=1
1240 TMSG$="何秒目までsaveしましょうか":GOSUB *WRITE_TMSG
1250 LOCATE 30,23 :INPUT LOC1 :CLS 4 :IF LOC1>30 THEN LOC1=30
1260 IF LOC1 <= LOC0 THEN RETURN
1270 NUM=(LOC1-LOC0)*19200
1280 LOC2=PCMDATAF%(6):LOC3=PCMDATA%(7)
1290 PCMDATA%(7)=NUM \ 65536
1300 NUM=NUM MOD 65536: IF NUM > 32767 THEN PCMDATA%(6)=NUM-65536 ELSE PCMDATA%(6)=NUM
1310 EXT$="snd":GOSUB *FILE_MSG
1320 IF MID$(A$,2,1)=":" THEN A$=LEFT$(A$,2)+"(1)"+RIGHT$(A$,LEN(A$)-2) ELSE A$="(1)"+A$
1330 TMSG$="save中です. "+WA$ :GOSUB *WRITE_TMSG
1340 ADR1=VARPTR(PCMDATA%(0))
1350 OPEN "R",#1,A$:FIELD #1,1 AS B$
1360 FOR I=1 TO 32
1370 LSET B$=CHR$(PEEK(ADR1)):PUT #1:ADR1=ADR1+1
1380 NEXT I
1390 ADR1=VARPTR(PCMDATA%(0))+LOC0*19200+32
1400 FOR J=LOC0 TO LOC1-1
1410 LOCATE 60,23:PRINT "今";J;"秒目です"
1420 FOR I=1 TO 19200
1430 LSET B$=CHR$(PEEK(ADR1)):PUT #1:ADR1=ADR1+1
1440 NEXT I
1450 NEXT J
1460 CLOSE #1
1470 GOSUB *ERASE_TMSG:CLS 4
1480 PCMDATA%(6)=LOC2:PCMDATA%(7)=LOC3
1490 RETURN
1500 '
1510 *HCOPY
1520 TMSG$="ハ-ドコピ-です" :GOSUB *WRITE_TMSG
1530 HARDC 1
1540 GOSUB *ERASE_TMSG
1550 RETURN
1560 '
1570 '
1580 '
1590 '
1600 *MAKE
1610 TMSG$="計算中です. "+WA$ :GOSUB *WRITE_TMSG
1620 MOUSE 1,,,0
1630 RETRY_F=1
1640 WHILE RETRY_F
1650 RETRY_F=0:CHENGE_F=1:MARK=0
1660 ADR1=VARPTR(PCMDATA%(0))+32
1670 FOR I=1 TO 600
1680 IF STAT%(I) >=63 THEN ADR1=ADR1+960:GOTO *F_END2
1690 CL=0
1700 GET@A (I+19,142)-(I+19,206),VDBUF%
1710 LOC0=STAT%(I)
1720 IF LOC1<>VDBUF%(128-LOC0*2) THEN CHENGE_F=1
1740 LOC1=VDBUF%(128-LOC0*2)
1750 IF LOC1 <> 0 AND LOC1<>MARK THEN *MK_SKIP1
1760 CHENGE_F=1:ADR1=ADR1+960
1770 IF LOC1=MARK AND MARK<>0 THEN CL=2 ELSE MARK=15:CL=0
1780 GOTO *F_END
1790 *MK_SKIP1
1800 IF CHENGE_F=0 THEN *MK_SKIP2
1810 ERASE PCMBUF% :DIM PCMBUF%(96016)
1820 LOAD@ FLNAMES$(LOC1),PCMBUF%
1830 ADR2=VARPTR(PCMBUF%(0))+32
1840 CHENGE_F=0
1850 *MK_SKIP2
1860 FOR J=LOC0 TO 63
1870 MARK=VDBUF%(128-J*2)
1880 IF VDBUF%(128-J*2) = 0 THEN *MK_BREAK
1890 IF VDBUF%(128-J*2) <> LOC1 THEN CL=1:RETRY_F=1:GOTO *MK_BREAK
1900 NEXT J
1910 MARK=0
1920 *MK_BREAK
1930 DIVP=64/(J-LOC0+.5!)
1940 STAT%(I)=J:LOC0=J
1950 '
1960 FOR K=1 TO 960
1970 A1=PEEK(ADR1):IF A1>127 THEN A1=128-A1
1980 A2=PEEK(ADR2):IF A2>127 THEN A2=128-A2
1990 A2=A1+A2\DIVP:IF A2<0 THEN A2=128-A2
2000 POKE ADR1,A2
2010 ADR1=ADR1+1:ADR2=ADR2+1
2020 NEXT K
2030 *F_END:
2040 LINE(I+19,231)-(I+19,239),PSET,%(CL+1)
2050 *F_END2
2060 NEXT I
2070 '
2080 WEND
2090 *MK_END
2100 GOSUB *ERASE_TMSG
2110 MOUSE 1,,,1
2120 RETURN
2130 '
2140 *FILE_LOAD '**/ (arg0 is index) [a$,loc0]
2150 EXT$="snd":GOSUB *FILE_MSG
2160 IF A$="" THEN FLNAMES$(ARG0)=A$:FLLNG&(ARG0)=0:GOTO *FL_SKIP2
2170 LOAD@ A$,PCMBUF% :PCMPLAY PCMBUF% :GOTO *FL_SKIP1
2180 A$="":FLNAMES$(ARG0)=A$:GOTO *FL_SKIP2
2190 *FL_SKIP1:FLNAMES$(ARG0)=A$
2200 IF PCMBUF%(6)>0 THEN FLLNG&(ARG0)=PCMBUF%(6)ELSE FLLNG&(ARG0)=65536+PCMBUF%(6)
2210 FLLNG&(ARG0)=FLLNG&(ARG0)+PCMBUF%(7)*65536
2220 *FL_SKIP2 :CLS 4 :GOSUB *ERASE_TMSG
2230 GOSUB *WRITE_ED_MENU
2240 RETURN
2250 '
2260 *PATTERN_EDIT '**/ (arg0 is index) [loc0,loc1,loc2,loc3]
2270 LOC0=ARG0-14:IF FLLNG&(LOC0)=0 THEN RETURN 'LOC0 is Color
2280 TMSG$="put Pattern to Sound Track" :GOSUB *WRITE_TMSG
2290 LINE(250,438)-(300,450),PSET,%LOC0,BF
2300 LOC2=0 ' LOC2 is start point
2310 LOC3=INT(FLLNG&(LOC0)/960)+1 ' LOC3 is right limit
2320 '
2330 WHILE LOC2 <LOC3
2340 LOC1=0 ' LOC1 is volume
2350 *WTOP
2360 GOSUB *GET_MOUSE:IF ARG0=1 THEN *P_E_END
2370 IF ARG1 < 20 OR ARG1 > 619 THEN *P_E_END 'ARG1 is end point of X
2380 IF ARG1 < LOC2 THEN *P_E_END
2390 IF ARG1 = LOC2 THEN *P_E_SKIP
2400 IF ARG2 < 142 THEN ARG2=142 'ARG2 is end point of Y
2410 IF ARG2 > 204 THEN ARG2=204
2420 IF LOC2 = 0 THEN LOC2=ARG1:LOC3=LOC3+ARG1:GOTO *WTOP
2430 IF ARG1 > LOC3 THEN ARG1=LOC3
2440 MOUSE 1,,,0 :I=LOC2
2450 WHILE I<ARG1
2460 L=206:IF POINT (I,ARG2)=-1 THEN *P_E_SKIP
2470 FOR K=ARG2+1 TO 206
2480 IF POINT (I,K) =-1 THEN L=K-1 :K=207
2490 NEXT K
2500 IF LOC1=0 THEN LOC1=2^INT(LOG(L-ARG2)/LOG(2)+.5!)
2520 K=LOC1 :WHILE L-K< 141: K=LOC1/2: WEND
2530 IF L<=ARG2 THEN *P_E_SKIP
2540 LINE(I,L)-(I,L-K+1),PSET,%LOC0
2550 LINE(I,231)-(I,239),PSET,%0
2560 *P_E_SKIP :I=I+1
2570 WEND
2580 LOC2=ARG1:MOUSE 1,ARG1,ARG2,1
2590 WEND
2600 *P_E_END:
2610 GOSUB *ERASE_TMSG
2620 GOSUB *ERASE_TMSG
2630 RETURN
2640 '
2650 *ERASE_PATTERN '**/ (arg1 is X posi.)
2660 LOC0=ARG1
2670 TMSG$="Erase":GOSUB *WRITE_TMSG 'LOC0 is start point of X
2680 GOSUB *GET_MOUSE :IF ARG0=1 THEN *E_P_END 'ARG1 is end point of X
2690 IF ARG1 <20 OR ARG1 >619 THEN *E_P_END 'ARG2 is end point of Y
2700 IF ARG2 < 230 OR ARG2 >240 THEN *E_P_END
2710 IF ARG1 < LOC0 THEN *E_P_END
2720 LINE(LOC0,142)-(ARG1,206),PSET,%0,BF
2730 LINE(LOC0,231)-(ARG1,239),PSET,%0,BF
2740 FOR I=LOC0-19 TO ARG1-19
2750 STAT%(I)=0 ' Header is 32 byte
2760 FOR K=32 TO 511 :PCMDATA%((I-1)*480+K)=128 :NEXT K
2770 LINE(I+19,231)-(I+19,239),PSET,%1
2780 NEXT I
2790 *E_P_END :GOSUB *ERASE_TMSG
2800 RETURN
2810 '
2820 MOUSE 1,,,1
2830 RETURN
2840 ':::::::::::::::::::::::::::::::::::: end Service Routine :::::::
2850 '
2860 '
2870 *GET_MOUSE '**/ RET. IS arg0,arg1,arg2 is botten,X,Y
2880 IF MOUSE (2,0) THEN ARG0=0::GOTO *M_ON
2890 IF MOUSE (2,1) THEN ARG0=1: GOTO *M_ON
2900 GOTO *GET_MOUSE
2910 *M_ON
2920 IF MOUSE(2,ARG0) THEN *M_ON
2930 ARG1=MOUSE(4,ARG0):ARG2=MOUSE(5,ARG0)
2940 RETURN
2950 '
2960 *GET_CMD_POSI '**/ (arg1,arg2 mouse posi.) [LOC0] ; RET. IS cmd_ind
2970 CMD_IND=0
2980 IF ARG1>460 AND ARG1< 500 THEN LOC0=0:GOTO *X_OK
2990 IF ARG1>560 AND ARG1< 640 THEN LOC0=1:GOTO *X_OK
3000 RETURN
3010 *X_OK
3020 IF ARG2>17 AND ARG2<103 THEN CMD_IND=LOC0*4+(ARG2-8)\19:RETURN
3030 RETURN
3040 '
3050 *GET_ED_POSI '**/ (arg1,arg2 mouse posi.) [LOC0]; RET. IS arg0
3060 IF ARG1>10 AND ARG1<620 AND ARG2>262 AND ARG2<396 THEN *BOX_OK
3070 ARG0=0:RETURN
3080 *BOX_OK
3090 LOC0=(ARG2-244)\19
3100 IF ARG1 < 100 THEN ARG0=LOC0:RETURN
3110 IF ARG1 < 300 THEN ARG0=LOC0+14:RETURN
3120 IF ARG1 < 420 THEN ARG0=LOC0+7:RETURN
3130 ARG0=LOC0+21
3140 RETURN
3150 '
3160 '
3170 *WRITE_ALL_CMD '**/ (cmd_sw is color)
3180 LINE(450,20)-(633,105),PSET,%15,BF,%0
3190 FOR CMD_IND=1 TO CMD_NUM
3200 GOSUB *WRITE_CMD
3210 NEXT CMD_IND
3220 RETURN
3230 '
3240 *WRITE_CMD '**/ (cmd_ind is index, cmd_sw is color)
3250 IF CMD_IND<5 THEN LOC0=460:LOC1=CMD_IND*19+10 ELSE LOC0=560:LOC1=CMD_IND*19-66
3260 SYMBOL (LOC0,LOC1),CMDNAMES$(CMD_IND),1,1,%CMD_SW,,,2
3270 RETURN
3280 '
3290 *WRITE_ED_MENU '**/ (ARG0 is index)[a$,loc0,loc1]
3300 IF ARG0=0 THEN RETURN
3310 A$=FLNAMES$(ARG0)
3320 GOSUB *PASS_BREAK
3330 IF A$="" THEN A$=" "+STR$(ARG0)
3340 '
3350 IF ARG0 >7 THEN LOC1=330:LOC2=115 ELSE LOC1=10:LOC2=248
3360 LINE(LOC1,ARG0*19+LOC2)-(LOC1+290,ARG0*19+LOC2+14),PSET,%0,BF
3370 LOC0=FLLNG&(ARG0)/960
3380 SYMBOL(LOC1,ARG0*19+LOC2),A$,1,1,%15,,,0
3390 LINE (LOC1+90,ARG0*19+LOC2)-(LOC0+LOC1+90,ARG0*19+LOC2+12),PSET,%ARG0,BF
3400 LINE (LOC0+LOC1+90,ARG0*19+LOC2)-(LOC1+290,ARG0*19+LOC2+12),PSET,%ARG0,B
3410 RETURN
3420 '
3430 '
3440 *WRITE_TMSG '**/ TMSG$ is message
3450 LINE(6,430)-(633,458),PSET,%15,BF,%0
3460 SYMBOL (17,437),TMSG$,1,1,%2,,,1
3470 RETURN
3480 '
3490 *ERASE_TMSG
3500 LINE(6,430)-(633,458),PSET,%15,BF,%0
3510 RETURN
3520 '
3530 '
3540 '
3550 *PASS_BREAK '**/ A$ is arg. and ret.
3560 LOC1=LEN(A$):LOC0=0
3570 IF MID$( A$,2,1)=":" THEN A$=MID$ (A$,3)
3580 FOR I=1 TO LOC1
3590 IF MID$ (A$,I,1) = "\" THEN LOC0=I
3600 NEXT I
3610 A$=MID$(A$,LOC0+1)
3620 LOC0=INSTR(A$,".")
3630 IF LOC0 <>0 THEN A$=LEFT$(A$,LOC0-1)
3640 RETURN
3650 '
3660 *FILE_MSG '**/ A$ is ret.
3670 TMSG$="Input File Name ":GOSUB *WRITE_TMSG
3680 LOCATE 20,23:LINE INPUT A$:CLS 4
3690 IF A$="" THEN *FM_SKIP
3700 LOC0=INSTR(A$,".")
3710 IF LOC0<>0 THEN A$=LEFT$(A$,LOC0)+EXT$ ELSE A$=A$+"."+EXT$
3720 *FM_SKIP :CLS 4 :GOSUB *ERASE_TMSG
3730 RETURN
3740 '
3750 '
3760 '
3770 *CMDNAMES
3780 DATA "play","record","make","quit","PCM save","HardCopy"
3790 *COLOR
3800 DATA 255,255,255, 0, 0,128, 0,128, 0, 0,128,128
3810 DATA 128, 0, 0,128, 0,128,128,128, 0,128,128,128
3820 DATA 64, 64, 64, 0, 0,255, 0,255, 0, 0,255,255
3830 DATA 255, 0, 0,255, 0,255,255, 0, 0, 0, 0, 0
3840 '
3850 *ERROR: TMSG$="Error No. "+STR$(ERR)+" マウスをクリックしてください":GOSUB *WRITE_TMSG: GOSUB *GET_MOUSE: GOSUB *ERASE_TMSG
3860 IF ERL=2170 THEN RESUME 2180
3870 RESUME NEXT
3880 '
3890 '